Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbalyz/mfuncs.bas

BASIC Source File | 1995-01-05 | 20.8 KB | 840 lines

Option Explicit

Global Const APP_NAME = "VB*Alyzer"

Dim mblnProjectSelected As Integer
Dim mstrProjectName  As String

Dim mstraProjFile() As String

Type Metric_Type
    Name As String
    LongName As String
    Display As Integer
End Type

Dim muaMetric(1 To 20) As Metric_Type

Type FileStats_Type
    Filename As String
    Metric(1 To 20)  As Single
    CurrentBeginEndLevel As Integer
    CurrentFunc As String
    CurrentComplexity As Integer
    WorstRoutine As String
End Type

Type Status_Type
    InRoutine As Integer
    InType As Integer
End Type

Dim muStatus As Status_Type

Const TOTSIZE = 1
Const TOTLINES = 2
Const BLANKLINES = 3
Const TOTCOMMENTS = 4
Const TOTROUTINES = 5
Const PRIVATEROUTINES = 6
Const LOCALVARS = 7
Const LOCALCONSTS = 8
Const MODULEVARS = 9
Const MODULECONSTS = 10
Const GLOBALVARS = 11
Const GLOBALCONSTS = 12
Const APIDECS = 13
Const TYPES = 14
Const TYPELINES = 15
Const AVERTNLINES = 16
Const RTNNONCODELINES = 17
Const ROUTINECODELINES = 18
Const ROUTINEDECPTS = 19
Const MOSTCOMPLEX = 20

Dim muTotStat As FileStats_Type

Sub AccumTotals (uStatIn As FileStats_Type)

' Add the values in the supplied stat record to the total record

Dim i As Integer

    For i = LBound(uStatIn.Metric) To UBound(uStatIn.Metric)
        If i <> MOSTCOMPLEX Then
            muTotStat.Metric(i) = muTotStat.Metric(i) + uStatIn.Metric(i)
        Else
            ' MostComplex should be a maximum
            If muTotStat.Metric(i) < uStatIn.Metric(i) Then
                muTotStat.Metric(i) = uStatIn.Metric(i)
            End If
        End If
    Next

End Sub

Sub AnalyzeCurrentProject (lst As Control, grd As Grid)

Dim i As Integer

    Screen.MousePointer = HOURGLASS

    ' Reset output grid
    ClearWholeGrid grd
    grd.Rows = 1
    SetGridHeadings grd

    ZeroProjectTotals

    ' For each file in list, take it apart
    For i = 0 To lst.ListCount - 1
        AnalyzeFile lst.List(i), grd
    Next

    ' Display stats
    ReportStats muTotStat, grd

    Screen.MousePointer = DEFAULT

End Sub

Sub AnalyzeFile (ByVal strFile As String, grd As Grid)

Dim intF As Integer
Dim strLine As String
Dim uStat As FileStats_Type

    intF = FreeFile

    Open strFile For Input As intF

    muStatus.InRoutine = False
    uStat.Filename = strFile

    Do
        Line Input #intF, strLine
        AnalyzeLine strLine, uStat
    Loop Until EOF(intF)

    ' Check last routine's complexity
    If muStatus.InRoutine Then
        CheckComplexity uStat, strLine
    End If

    Close intF

    ReportStats uStat, grd

    AccumTotals uStat

End Sub

Sub AnalyzeLine (ByVal strLine As String, uStat As FileStats_Type)

' This is the main engine for the whole metric part of the program
' It's not very nice, and should probably be broken up. Sooner rather
' than later.

    ' Add Line lingth to total size
    uStat.Metric(TOTSIZE) = uStat.Metric(TOTSIZE) + Len(strLine)

    ' Remove leading/trailing spaces
    strLine = Trim$(strLine)

    ' If working on a form, ignore control description info,
    ' identifiable by "Begin" and "End". Keep track of current
    ' "level": while > 0 we're still working in the uninteresting
    ' part of the file.
    If Right$(uStat.Filename, 3) = "FRM" Then
        If IsLeftEnd(strLine, "Begin") Then
            uStat.CurrentBeginEndLevel = uStat.CurrentBeginEndLevel + 1
            Exit Sub
        End If
        If uStat.CurrentBeginEndLevel > 0 Then
            If IsLeftEnd(strLine, "End") Then
                uStat.CurrentBeginEndLevel = uStat.CurrentBeginEndLevel - 1
                Exit Sub
            End If
        End If
        If uStat.CurrentBeginEndLevel > 0 Then
            Exit Sub
        End If
    End If

    ' Increment total lines
    inc uStat, TOTLINES

    ' If blank line, increment blank count
    If Len(strLine) = 0 Then
        inc uStat, BLANKLINES
        ' If blank is in a routine, increment non-code line count
        If muStatus.InRoutine Then
            inc uStat, RTNNONCODELINES
        End If
        Exit Sub
    End If

    ' If comment... (Note no allowance made for trailing comments)
    If Left$(strLine, 1) = "'" Then
        inc uStat, TOTCOMMENTS
        If muStatus.InRoutine Then
            inc uStat, RTNNONCODELINES
        End If
        Exit Sub
    End If

    If IsLeftEnd(strLine, "Private") Then
        inc uStat, PRIVATEROUTINES
        StripLeftmostWord strLine
    End If

    ' Check current line for being a routine (= Sub or Function)
    If IsRoutine(strLine) Then

        muStatus.InRoutine = True
        inc uStat, TOTROUTINES

        CheckComplexity uStat, strLine

        ' Uses McCabe complexity metric, counting decision points.
        ' A routine's Decision Pt count is always 1, even if
        ' there's nothing else of significance in the routine
        inc uStat, ROUTINEDECPTS
        uStat.CurrentComplexity = 1

        ' Get routine name by removing the Sub or Function part...
        StripLeftmostWord strLine

        ' ...and taking the next word
        uStat.CurrentFunc = LeftMostWord(strLine)

        Exit Sub
    End If

    ' Are we defining a variable?
    If IsLeftEnd(strLine, "Dim") Then
        If muStatus.InRoutine Then
            inc uStat, LOCALVARS
            inc uStat, RTNNONCODELINES
        Else
            inc uStat, MODULEVARS
        End If
        Exit Sub
    End If

    ' How about a Constant?
    If IsLeftEnd(strLine, "Const") Then
        If muStatus.InRoutine Then
            inc uStat, LOCALCONSTS
            inc uStat, RTNNONCODELINES
        Else
            inc uStat, MODULECONSTS
        End If
        Exit Sub
    End If

    ' Is something being defined globally?
    If IsLeftEnd(strLine, "Global") Then
        ' Is it a constant?
        If InStr(strLine, " Const ") Then
            inc uStat, GLOBALCONSTS
        Else
        ' If not, it must be a variable of some sort
            inc uStat, GLOBALVARS
        End If
        Exit Sub
    End If

    ' Check for API declarations (includes all DLL links)
    If IsLeftEnd(strLine, "Declare Sub") Or IsLeftEnd(strLine, "Declare Function") Then
        inc uStat, APIDECS
        Exit Sub
    End If

    ' If we're not currently processing a Type, then check to see
    ' if one's just turned up...
    If Not muStatus.InType Then
        ' If it has, then record the fact
        If IsLeftEnd(strLine, "Type") Then
            muStatus.InType = True
            inc uStat, TYPES
            Exit Sub
        End If
    End If

    ' if we're in a Type declaration,
    If muStatus.InType Then
        ' Check for the end of it
        If IsLeftEnd(strLine, "End Type") Then
            muStatus.InType = False
            inc uStat, TYPELINES
        Else
            inc uStat, TYPELINES
        End If
        Exit Sub
    End If

    ' If we're in a routine, check this line for decision
    ' points.
    If muStatus.InRoutine Then
        CountDecisionPoints strLine, uStat
        ' Since we've got this far, and exited earlier if
        ' non-"action code" lines were encountered, it's a
        ' reasonable bet that this line _is_ "action code"
        inc uStat, ROUTINECODELINES
    End If

End Sub

Sub CheckComplexity (uStat As FileStats_Type, strLine As String)

    ' if in a routine, check to see if the last routine was more complex
    ' than that currently stored
    If muStatus.InRoutine Then
        If uStat.CurrentComplexity > uStat.Metric(MOSTCOMPLEX) Then
            uStat.Metric(MOSTCOMPLEX) = uStat.CurrentComplexity
            uStat.WorstRoutine = uStat.CurrentFunc
        End If
    End If

End Sub

Sub ClearProjectFileList ()

    ReDim mstraProjFile(1 To 1)

End Sub

Sub CountDecisionPoints (ByVal strLine As String, uStat As FileStats_Type)

Dim intDecPts As Integer

    ' Check for lines beginning Select Case/For/Do/While
    If IsLeftEnd(strLine, "Select Case") Then
        inc uStat, ROUTINEDECPTS
        uStat.CurrentComplexity = uStat.CurrentComplexity + 1
        Exit Sub
    End If

    If IsLeftEnd(strLine, "For") Then
        inc uStat, ROUTINEDECPTS
        uStat.CurrentComplexity = uStat.CurrentComplexity + 1
        Exit Sub
    End If

    If IsLeftEnd(strLine, "Do") Then
        inc uStat, ROUTINEDECPTS
        uStat.CurrentComplexity = uStat.CurrentComplexity + 1
        Exit Sub
    End If

    If IsLeftEnd(strLine, "While") Then
        inc uStat, ROUTINEDECPTS
        uStat.CurrentComplexity = uStat.CurrentComplexity + 1
        Exit Sub
    End If

    ' with Ifs and ElseIfs, check also for Ands and Ors
    If IsLeftEnd(strLine, "If") Or IsLeftEnd(strLine, "ElseIf") Then

        inc uStat, ROUTINEDECPTS
        strLine = Trim$(Mid$(strLine, 3))
        uStat.CurrentComplexity = uStat.CurrentComplexity + 1

        intDecPts = NumOccurrences(strLine, " And ")
        uStat.Metric(ROUTINEDECPTS) = uStat.Metric(ROUTINEDECPTS) + intDecPts
        uStat.CurrentComplexity = uStat.CurrentComplexity + intDecPts

        intDecPts = NumOccurrences(strLine, " Or ")
        uStat.Metric(ROUTINEDECPTS) = uStat.Metric(ROUTINEDECPTS) + intDecPts
        uStat.CurrentComplexity = uStat.CurrentComplexity + intDecPts

    End If

End Sub

Function DisplayMetric (intIdx As Integer) As Integer

    DisplayMetric = muaMetric(intIdx).Display

End Function

Function Filename (strPath As String) As String

' Remove all the path stuff from a pathname

Dim intStart

    ' If no path in string, that's it
    If InStr(strPath, "\") = 0 Then
        Filename = strPath
        Exit Function
    End If

    ' Work back from end until \ found, then return the RHS
    For intStart = Len(strPath) To 1 Step -1
        If Mid$(strPath, intStart, 1) = "\" Then
            intStart = intStart + 1
            Filename = Mid$(strPath, intStart)
            Exit Function
        End If
    Next

    Filename = "#ERROR#"

End Function

Sub FillFileList (lst As Control)

Dim i As Integer

    lst.Clear

    For i = LBound(mstraProjFile) To UBound(mstraProjFile)
        If Len(mstraProjFile(i)) > 0 Then
            lst.AddItem mstraProjFile(i)
        End If
    Next

End Sub

Sub GetProjectToUse (dlg As CommonDialog)

' Use common dialog to get a .MAK file

    dlg.DialogTitle = "Open Project"
    dlg.Filter = "VB Project (*.mak)|*.mak|All files (*.*)|*.*"
    dlg.Flags = OFN_FILEMUSTEXIST
    dlg.Action = DLG_FILE_OPEN

    If dlg.Filename <> "" Then
        mstrProjectName = dlg.Filename
        mblnProjectSelected = True
    Else
        mblnProjectSelected = False
    End If

End Sub

Sub inc (uStat As FileStats_Type, intMetricIdx As Integer)

' increment a specified metric within a FileStats_Type

    uStat.Metric(intMetricIdx) = uStat.Metric(intMetricIdx) + 1

End Sub

Sub Initialise ()

    mblnProjectSelected = False
    mstrProjectName = ""

    ReDim mstraProjFile(1 To 1)

    ' keep to 8 chars or less
    muaMetric(TOTSIZE).Name = "TotBytes"
    muaMetric(TOTLINES).Name = "TotLines"
    muaMetric(BLANKLINES).Name = "Blanks"
    muaMetric(TOTCOMMENTS).Name = "Comments"
    muaMetric(TOTROUTINES).Name = "Routines"
    muaMetric(PRIVATEROUTINES).Name = "PrivRtns"
    muaMetric(LOCALVARS).Name = "LocVars"
    muaMetric(LOCALCONSTS).Name = "LocCnst"
    muaMetric(MODULEVARS).Name = "ModVars"
    muaMetric(MODULECONSTS).Name = "ModCnst"
    muaMetric(GLOBALVARS).Name = "GblVars"
    muaMetric(GLOBALCONSTS).Name = "GlbCnst"
    muaMetric(APIDECS).Name = "APIs"
    muaMetric(TYPES).Name = "Types"
    muaMetric(TYPELINES).Name = "TypLns"
    muaMetric(AVERTNLINES).Name = "AveRtLns"
    muaMetric(RTNNONCODELINES).Name = "NonCdLns"
    muaMetric(ROUTINECODELINES).Name = "RtnCdLns"
    muaMetric(ROUTINEDECPTS).Name = "RtDecPts"
    muaMetric(MOSTCOMPLEX).Name = "MostDPs"

    muaMetric(TOTSIZE).Display = True
    muaMetric(TOTLINES).Display = True
    muaMetric(BLANKLINES).Display = True
    muaMetric(TOTCOMMENTS).Display = True
    muaMetric(TOTROUTINES).Display = True
    muaMetric(PRIVATEROUTINES).Display = True
    muaMetric(LOCALVARS).Display = False
    muaMetric(LOCALCONSTS).Display = False
    muaMetric(MODULEVARS).Display = True
    muaMetric(MODULECONSTS).Display = False
    muaMetric(GLOBALVARS).Display = True
    muaMetric(GLOBALCONSTS).Display = True
    muaMetric(APIDECS).Display = False
    muaMetric(TYPES).Display = False
    muaMetric(TYPELINES).Display = False
    muaMetric(AVERTNLINES).Display = True
    muaMetric(RTNNONCODELINES).Display = True
    muaMetric(ROUTINECODELINES).Display = True
    muaMetric(ROUTINEDECPTS).Display = True
    muaMetric(MOSTCOMPLEX).Display = True

    muaMetric(TOTSIZE).LongName = "Total File Bytes"
    muaMetric(TOTLINES).LongName = "Total # Lines"
    muaMetric(BLANKLINES).LongName = "Blank Lines"
    muaMetric(TOTCOMMENTS).LongName = "Comments"
    muaMetric(TOTROUTINES).LongName = "Routines"
    muaMetric(PRIVATEROUTINES).LongName = "Private Rtns"
    muaMetric(LOCALVARS).LongName = "Local Vars"
    muaMetric(LOCALCONSTS).LongName = "Local Consts"
    muaMetric(MODULEVARS).LongName = "Module Vars"
    muaMetric(MODULECONSTS).LongName = "Module Constants"
    muaMetric(GLOBALVARS).LongName = "Global Vars"
    muaMetric(GLOBALCONSTS).LongName = "Global Consts"
    muaMetric(APIDECS).LongName = "API Decl's"
    muaMetric(TYPES).LongName = "Type Definitions"
    muaMetric(TYPELINES).LongName = "Type Lines"
    muaMetric(AVERTNLINES).LongName = "Ave Lines/Routine"
    muaMetric(RTNNONCODELINES).LongName = "Non-Code Routine Lines"
    muaMetric(ROUTINECODELINES).LongName = "Routine Code Lines"
    muaMetric(ROUTINEDECPTS).LongName = "Routine Decision Points"
    muaMetric(MOSTCOMPLEX).LongName = "Most Complex Dec Pts"

End Sub

Function IsLeftEnd (strToCheck, strToFind) As Integer

Dim intLen As Integer

    intLen = Len(strToFind) + 1

    If Left$(strToCheck, intLen) = strToFind & " " Or Left$(strToCheck, intLen) = strToFind Then
        IsLeftEnd = True
    Else
        IsLeftEnd = False
    End If

End Function

Function IsRoutine (strLine) As Integer

    If LeftMostWord(strLine) = "Sub" Then
        IsRoutine = True
    ElseIf LeftMostWord(strLine) = "Function" Then
        IsRoutine = True
    Else
        IsRoutine = False
    End If

End Function

Function IsUserProjectFile (strFile As String) As Integer

Dim strExt As String

    strExt = Right$(strFile, 3)
    If strExt = "BAS" Then
        IsUserProjectFile = True
    ElseIf strExt = "FRM" Then
        IsUserProjectFile = True
    Else
        IsUserProjectFile = False
    End If

End Function

Function MetricLongName (intIdx As Integer) As String

    MetricLongName = muaMetric(intIdx).LongName

End Function

Function MetricName (intIdx) As String

    MetricName = muaMetric(intIdx).Name

End Function

Function MetricsInUse () As Integer

Dim i As Integer
Dim intCount As Integer

    For i = LBound(muaMetric) To UBound(muaMetric)
        If muaMetric(i).Display Then
            intCount = intCount + 1
        End If
    Next

    MetricsInUse = intCount

End Function

Function MetricValue (uStat As FileStats_Type, intIdx As Integer) As Single

Dim sngValue As Single

    sngValue = uStat.Metric(intIdx)

    If Int(sngValue) <> sngValue Then
        sngValue = Int(sngValue * 100) / 100
    End If

    MetricValue = sngValue

End Function

Function NumMetrics () As Integer

Dim intCount As Integer
Dim intIdx As Integer

    For intIdx = LBound(muaMetric) To UBound(muaMetric)
        If Len(muaMetric(intIdx).Name) > 0 Then
            intCount = intCount + 1
        End If
    Next

    NumMetrics = intCount

End Function

Sub OpenProject (lst As Control, dlg As CommonDialog)

    ClearProjectFileList

' Find out what project is to be analysed
    GetProjectToUse dlg

' If a project was selected, alter the caption to reflect this
    If ProjectSelected() Then
        SetFormCaption frmMain
    Else
        ResetFormCaption frmMain
    End If

    OpenProjectFile
    FillFileList lst

End Sub

Sub OpenProjectFile ()

Dim intF As Integer
Dim strLine As String
Dim strProj As String

    intF = FreeFile

    strProj = ProjectName()

    If Len(strProj) <= 0 Then
        Exit Sub
    End If

    Open ProjectName() For Input As intF

    Do
        Input #intF, strLine
        If IsUserProjectFile(strLine) Then
            StoreProjectFile strLine
        End If
    Loop Until EOF(intF)

    Close intF

End Sub

Sub PrintResults (grd As Grid)

Dim lngRow As Long
Dim lngCol As Long
Dim strOut As String

    Printer.FontSize = 8

    Screen.MousePointer = HOURGLASS

    Printer.CurrentX = 200
    Printer.Print ProjectName()
    Printer.Print

    For lngRow = 0 To grd.Rows - 1

        Printer.CurrentX = 200
        strOut = RPad(GridText(grd, 0, lngRow), 12)
        Printer.Print strOut;

        For lngCol = 1 To grd.Cols - 1
            If lngCol < grd.Cols - 1 Then
                strOut = Space$(9)
                RSet strOut = GridText(grd, lngCol, lngRow)
            Else
                strOut = " " & GridText(grd, lngCol, lngRow)
            End If
            Printer.Print strOut;

        Next
        Printer.Print
    Next

    Printer.EndDoc

    Screen.MousePointer = DEFAULT

End Sub

Function ProjectName () As String

    ProjectName = mstrProjectName

End Function

Function ProjectSelected () As Integer

    ProjectSelected = mblnProjectSelected

End Function

Sub ReopenProject (lst As Control)

    ClearProjectFileList

    OpenProjectFile
    FillFileList lst

End Sub

Sub ReportStats (uStat As FileStats_Type, grd As Grid)

Dim lngRow As Long
Dim lngCols As Long
Dim strClip As String
Dim cTAB As String * 1
Dim i As Integer

    cTAB = Chr$(9)

    If uStat.Metric(TOTROUTINES) > 0 Then
        uStat.Metric(AVERTNLINES) = (uStat.Metric(ROUTINECODELINES) + uStat.Metric(RTNNONCODELINES)) / uStat.Metric(TOTROUTINES)
    End If

    If DisplayMetric(MOSTCOMPLEX) Then
        lngCols = MetricsInUse() + 2
    Else
        lngCols = MetricsInUse() + 1
    End If

    grd.Cols = lngCols
    grd.Rows = grd.Rows + 1
    lngRow = grd.Rows - 1

    strClip = uStat.Filename & "|"

    For i = 1 To NumMetrics()
        If DisplayMetric(i) Then
            strClip = strClip & MetricValue(uStat, i) & "|"
        End If
    Next

    If DisplayMetric(MOSTCOMPLEX) Then
        strClip = strClip & uStat.WorstRoutine
    End If

    Replace strClip, "|", cTAB

    SetGridClip grd, lngRow, 0, 1, (grd.Cols), strClip

End Sub

Sub ResetFormCaption (frm As Form)

    frm.Caption = APP_NAME

End Sub

Sub SetFormCaption (frm As Form)

    frm.Caption = APP_NAME & "(" & ProjectName() & ")"

End Sub

Sub SetGridHeadings (grd As Grid)

Dim i As Integer
Dim lngCurrCol As Long
Dim strHdg As String
Dim cTAB As String * 1

    cTAB = Chr$(9)

    grd.Cols = MetricsInUse() + 1
    grd.Cols = grd.Cols + IIf(DisplayMetric(MOSTCOMPLEX), 1, 0)

    strHdg = "FileName|"

    grd.ColWidth(0) = frmMain.TextWidth("nnnnnnnnnnnn")

    lngCurrCol = 1
    For i = 1 To NumMetrics()
        If DisplayMetric(i) Then
            grd.ColWidth(lngCurrCol) = frmMain.TextWidth("nnnnnn")
            grd.ColAlignment(lngCurrCol) = 1
            strHdg = strHdg & MetricName(i) & "|"
            lngCurrCol = lngCurrCol + 1
        End If
    Next

    If DisplayMetric(MOSTCOMPLEX) Then
        grd.ColWidth(lngCurrCol) = frmMain.TextWidth("nnnnnnnnnnnnnnnn")
        strHdg = strHdg & "WorstRtn"
    End If

    Replace strHdg, "|", cTAB

    SetGridClip grd, 0, 0, 1, grd.Cols, strHdg

End Sub

Sub SetMetricDisplay (intIdx As Integer, ByVal intVal As Integer)

    muaMetric(intIdx).Display = intVal

End Sub

Sub StoreProjectFile (strFile As String)

    ' If last entry in array is already in use
    If Len(mstraProjFile(UBound(mstraProjFile))) > 0 Then
        ' Resize array to add another slot
        ReDim Preserve mstraProjFile(LBound(mstraProjFile) To UBound(mstraProjFile) + 1)
    End If

    ' Now use the new slot
    mstraProjFile(UBound(mstraProjFile)) = strFile

End Sub

Sub StripLeftmostWord (strIn As String)

    If InStr(strIn, " ") = 0 Then
        strIn = ""
    Else
        strIn = Trim$(Mid$(strIn, InStr(strIn, " ")))
    End If

End Sub

Sub Terminate ()

' Handle any special termination processing here

End Sub

Sub ZeroProjectTotals ()

Dim i As Integer

    muTotStat.Filename = "Totals"
    For i = LBound(muTotStat.Metric) To UBound(muTotStat.Metric)
        muTotStat.Metric(i) = 0
    Next

End Sub